home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / Modules < prev    next >
Text File  |  1998-05-18  |  16KB  |  617 lines
  1. (*
  2. This file implements relocatable modules.  In installed applications on
  3. the 68k, these became separate code segments.
  4.  
  5. Modules live in separate files, and when needed, they're loaded into
  6. a handle.
  7.  
  8. The management of modules is rolled into class Module - each module
  9. we define gets a Module object which lives in the dictionary, and
  10. handles the housekeeping details related to the module files.
  11.  
  12.  
  13. Here's the module file format:
  14.  
  15. Header:
  16.     (offs 0 )    4 bytes        date/time compiled
  17.     (offs 4 )    4 bytes        DirID of source file
  18.     (offs 8 )    4 bytes        self-relative offset to exports table
  19.                             (which follows the code)
  20.     (offs 12)    4 bytes        code size
  21.     (offs 16)    4 bytes        self-relative offset to data start
  22.  
  23. Code
  24.  
  25. Exports table:
  26.     (offs 0 )    4 bytes        offset from header start to first cfa
  27.     (offs 4 )    4 bytes        offset to next cfa
  28.     ...
  29.     (offs n )    4 bytes        -1        marker for end of exports table
  30.  
  31. *)
  32.  
  33.  
  34.  
  35. true    value    CLEANMOD?
  36. false    value    RELEASED?
  37.     0    value    THIS_MOD
  38.     0    value    LAST_MOD
  39.     0    value    svDP
  40.     0    value    evSvDP
  41.     0    value    svLatest
  42.     0    value    evSvLatest
  43.     0    value    modstart
  44.  
  45.     string    $EXP
  46.     string    $CXT
  47.     string    $evCXT
  48.  
  49. ¥ variable    SAVE_CONTEXT    8 4 *  allot
  50.  
  51. : UNEVAL    ¥ Puts things back to normal after an EVAL"
  52.     evSvDP  0EXIT        ¥ Out if we're not compiling an eval"
  53.     evSvLatest -> latest
  54.     evSvDP -> DP  0 -> evSvDP
  55.     nil?: $evCxt  NIF  ptr: $evCxt  context  32 cmove  release: $evCxt  THEN
  56. ;
  57.  
  58. : UNMOD        ¥ Puts things back to normal after a module
  59.             ¥ or stand-alone code compilation or eval"
  60.     unEval
  61.     svDP  0EXIT        ¥ Out if we're not compiling a module/SA
  62.     svLatest -> latest
  63.     svDP -> DP  0 -> svDP  0 -> compMod
  64.     nil?: $cxt  NIF  ptr: $cxt  context  32  cmove  release: $cxt  THEN
  65.     false -> SAcomp?  ;
  66.  
  67. : >NXTEXP    ¥ ( cfa -- )  Adds the next cfa offset to the string $exp
  68.             ¥  which will become the exports table.
  69.     modstart -  pad !  pad 4  add: $exp  ;
  70.  
  71.  
  72. :class    MODULE    super{ object }
  73.  
  74. record
  75. {    handle    MODHDL
  76.     byte    EXEC_CNT        ¥ Must be at an even offset since we sometimes
  77.     bool    LOCKED?            ¥  do a combined access to exec_cnt and locked? !
  78.     byte    FLAGS
  79.     int        RES#
  80.     int        #IMP
  81.     dicaddr    LASTIMP
  82.     dicaddr    LOADPOINT
  83.     var        DicDateTime
  84.     int        RELOFFS
  85.     int        INSTALL?
  86. }
  87.  
  88. :m BASE:
  89.     nil?: modHdl  IF  0  EXIT  THEN
  90.     nptr: modHdl  ;m
  91.  
  92. :m HANDLE:    get: modHdl  ;m
  93.  
  94. :m .ID:        ^base obj>  .id  ;m
  95.  
  96. :m SETRELEASE:    ¥ ( addr -- )
  97.     modbase -  put: relOffs  ;m
  98.  
  99. :m SETRESID:    ¥ ( resID -- )
  100.     put: res#  ;m
  101.  
  102. :m INSTALL?:    get: install?  ;m
  103. :m SETINSTALL:    put: install?  ;m
  104.  
  105.  
  106. ¥ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark
  107. ¥ a module as unloaded in the saved image without really unloading it.
  108.  
  109. :m KLUDGE:    ¥ ( -- modHdl flags exec+locked? )
  110.     get: modHdl  get: flags  addr: exec_cnt  w@  nilH  put: modHdl  ;m
  111.  
  112. :m UNKLUDGE:    ¥ ( modHdl flags exec+locked? -- )
  113.     addr: exec_cnt  w!  put: flags  put: modHdl  ;m
  114.  
  115. :m GETNAME:    ¥ ( -- addr len )
  116.     ^base  obj> >name n>count  ;m
  117.  
  118. :m EXTNAME:  { xaddr xlen ¥ len -- addr' len' }
  119.     getName: self  -> len   pad len cmove
  120.     xaddr  pad len +  xlen  cmove        ¥ Add extension
  121.     pad  len xlen +  ;m
  122.  
  123. :m BINNAME:    ¥ ( -- addr len )  Leaves name of binary file for module.
  124.     " .BIN" extName: self  ;m
  125.  
  126. :m TXTNAME:    ¥ ( -- addr len )  Leaves name of text file for module.
  127.     " .TXT" extName: self  ;m
  128.  
  129.  
  130. :m LOAD:  { ¥ rc -- }        ¥ Loads if not loaded already
  131.     nil?: modHdl  0EXIT
  132.     get: res#
  133.     IF    'type CODE  get: res#  getRes  dup 0= ?error 138
  134.         put: modHdl
  135.     ELSE
  136.         binName: self  name: fFcb  0 setVref: fFcb
  137.         openReadOnly: fFcb  ?error 138
  138.         ['] pause 4+ @  0 -> pause        ¥ Disable pause over read to avoid
  139.                                         ¥  possible reentrancy
  140.         size: fFcb  dup  new: modHdl
  141.         lock: modHdl                    ¥ Maybe we need this
  142.         ptr: modHdl  swap  read: fFcb  -> rc
  143.         ['] pause 4+ !                    ¥ Restore pause
  144.         unlock: modHdl                    ¥ Unlock before error check
  145.         close: fFcb  drop  rc ?error 141
  146.         base: self @  get: dicDateTime  u<
  147.         IF                                ¥ BIN file is old version
  148.             release: modHdl  148 die
  149.         THEN
  150.     THEN
  151.     moveHi: modHdl                        ¥ Move module hi since it gets locked
  152.     clear: exec_cnt  ;m
  153.  
  154.  
  155. :m RELEASE:  { ¥ svModbase -- }
  156.     clear: exec_cnt                    ¥ We certainly hope we know what we're
  157.     clear: locked?                    ¥  doing!!
  158.     get: modHdl  nilH =  ?EXIT        ¥ Out if not loaded
  159.     get: relOffs  -1 <>                ¥ Any module-specific action?
  160.     IF                                ¥ Yes
  161.         lock: modHdl                ¥ We're going to execute in the module
  162.         modbase -> svModbase
  163.         ptr: modHdl  32766 +  dup  -> modbase
  164.         get: relOffs +
  165.         execute                        ¥ Execute the appropriate word
  166.         svModbase -> modbase        ¥ No need to unlock since we're
  167.                                     ¥  just about to release
  168.     THEN
  169.     get: res#                          ¥ Resource?
  170.     IF
  171.         get: modHdl  trap$ a9a3        ¥ call ReleaseResource
  172.         nilH put: modHdl
  173.     ELSE
  174.         release: modHdl
  175.     THEN
  176.     true -> released?  ;m
  177.  
  178. (*
  179. KEEP: and DROP: flag this module as needed and not needed, respectively.
  180. The main purpose of this flagging is that if GETSPACE is called, loaded
  181. modules will be released to make room, unless they have been flagged as
  182. needed by KEEP:.  But note that RELEASE: ignores the flag, so that we
  183. can get rid of a module by force if necessary.  This may happen if there
  184. was a crash while the module was executing.
  185.  
  186. LOCK: is more drastic than KEEP:, since it means that this module becomes
  187. non-relocatable.  UNLOCK: reverses a LOCK:.  Note that DROP: in effect does
  188. an UNLOCK: as well.
  189.  
  190. This "locking" feature is used for ExtrasMod, which has a window, and
  191. for the debugger and printMod, which can be entered through the back
  192. door (via a vect or a trap).  (By the way, we hope we won't have to do this
  193. back door business anywhere else.  Entering a module through the back door
  194. is not usually a very safe thing to do.)
  195.  
  196. Locking a module can give a useful performance improvement if a module is to
  197. be called several times in succession, since we bypass the _HLock and _Hunlock
  198. calls if the module is marked locked.
  199. *)
  200.  
  201. :m KEEP:
  202.     addr: flags 1 bset  ;m
  203.  
  204. :m DROP:
  205.     get: exec_cnt NIF  unlock: modHdl  THEN  ¥ Unlock if not executing
  206.     addr: flags 1 breset  clear: locked?  ;m
  207.  
  208. :m LOCK:
  209.     true  put: locked?  load: self  lock: modHdl  ;m
  210.         ¥ Note: loading does a MoveHi so we don't need to do it again.
  211.  
  212. :m UNLOCK:
  213.     false  put: locked?
  214.     get: exec_cnt NIF  nil?: modHdl NIF  unlock: modHdl  THEN THEN  ;m
  215.  
  216. :m KEEP?:
  217.     get: exec_cnt  0<>  get: locked?  or  get: flags  or  ;m
  218.  
  219. :m LOCKED?:
  220.     get: exec_cnt  get: locked?  or  ;m
  221.  
  222.  
  223. :m ?RELEASE:
  224.     keep?: self  ?EXIT
  225.     release: self  ;m
  226.  
  227. :m #IMP:    get: #imp  ;m
  228.  
  229. :m GETIMPORTS:  { ¥ n -- }
  230.     0 -> n
  231.     BEGIN
  232.         header  -92 w,        ¥ Header with handler code for imported word
  233.         ^base compimp  1 ++> n
  234.         & }  endlist?
  235.     UNTIL
  236.     n 1-  put: #imp
  237.     latest  name>  put: lastimp
  238.     here  put: loadpoint  ;m
  239.  
  240.  
  241. ¥                ===================================
  242. ¥                        Module compilation
  243. ¥                ===================================
  244.  
  245. private
  246.  
  247. :m ExpSupers:  { ^nw -- }
  248.     BEGIN
  249.         ^nw @ 0EXIT
  250.         ^nw relocType  InThisMod =
  251.         IF  ^nw @abs 4+            ¥ get to start of methods area in class info
  252.             8 FOR                ¥ go through the 8 method threads
  253.                 dup displace  i expMethods: [self]
  254.                 4+
  255.             NEXT  drop
  256.         THEN
  257.         4 ++> ^nw
  258.     AGAIN  ;m
  259.  
  260. public
  261.             ¥ This gets called via a late bind, so must be public
  262.  
  263. :m ExpMethods:  { maddr thread# -- }
  264.     BEGIN                ¥ Loop thru methods in this class
  265.         maddr @ 0>=
  266.         IF                ¥ We've come to the superclasses - we only
  267.                         ¥  have to handle these once, of course - and
  268.                         ¥  since the order in the export table is
  269.                         ¥  immaterial, we'll just do it if we're on
  270.                         ¥  thread zero.
  271.             thread#
  272.             NIF  maddr  expSupers: self
  273.             THEN  EXIT
  274.         THEN
  275.                     ¥ Next method
  276.         maddr 10 +  ( cfa of method )  >nxtExp
  277.         maddr 4+ displace  -> maddr
  278.     AGAIN  ;m
  279.  
  280. private
  281.  
  282.  
  283. mlocal !exports: { ¥ thisImp thisCfa maddr -- }
  284.  
  285. :m ?!class:    ¥ If this exported item is a class, we set the handler
  286.             ¥ code of the imported version and add the method entry offsets
  287.             ¥ to the export table.
  288.  
  289.     thisCfa 2- w@x -58 =  0EXIT        ¥ Out if it isn't a class
  290.     -90  thisImp 2- w!
  291.     thisCfa ffa 1+ 1 bset
  292.     thisCfa 4+                ¥ get to start of methods area in class info
  293.     8 FOR                    ¥ go through the 8 method threads
  294.         dup displace  i expMethods: self
  295.         4+
  296.     NEXT  drop  ;m
  297.  
  298.  
  299. :m 1export:
  300.     next: theMark  link> -> thisImp
  301.     thisImp  >name n>count  sFind
  302.     drop -> thisCfa
  303.     thisCfa thisImp =
  304.     IF                                        ¥ Not defined
  305.         cr thisImp .id  2 spaces  144 die
  306.                                     ¥ "You forgot to define this exported name"
  307.         false -> cleanMod?
  308.     ELSE                            ¥ All OK. Put info into import definition:
  309.         thisCfa >name c@  thisImp >name c!    ¥ Name flags
  310.         pos: $exp  thisImp 4+ w!            ¥ Export table index
  311.         thisCfa >nxtExp                        ¥ Add next exp tbl entry
  312.         ?!class: self                        ¥ More stuff if it's a class
  313.     THEN  ;m
  314.  
  315.  
  316. :mloc !exports:        ¥ { ¥ n thisImp thisCfa maddr -- }
  317.     get: #imp  0= ?error 143            ¥ Module has no exported names
  318.     clear: $exp
  319.     get: lastimp  set: theMark
  320.     get: #imp  FOR  1export: self  NEXT
  321.     -1 pad !  pad 4 add: $exp            ¥ marker at end of table
  322. ;mloc
  323.  
  324.  
  325. (*
  326. FixLinks: fixes up the dictionary links within the compiled module.  We may
  327. want to find words in the module at run time via FIND, but the problem is that
  328. dic links are relative, not relocatable.  This makes FIND fast, but leads
  329. to a problem at run time when the the module is disconnected from the main
  330. dictionary.  If we didn't do anything, we wouldn't know where to start
  331. searching from, and if the search failed, the last link would point into
  332. outer space.
  333. So what we do is to add a snapshot of CONTEXT to the end of the module to give
  334. a place to start from, and to clear the lowest link on each thread to zero (which
  335. means the end).
  336. *)
  337.  
  338. :m FixLinks:  { ¥ link prevLink -- }
  339.     #threads FOR
  340.         context  i cells +  -> link
  341.         BEGIN
  342.             link -> prevLink
  343.             link displace -> link
  344.             link modstart u<
  345.         UNTIL
  346.         0 prevLink !
  347.     NEXT
  348.     here 4+ context -  ,            ¥ Adjustment value for context copy
  349.     context 32  n,                    ¥ Add copy of Context to end of module
  350. ;m
  351.  
  352. :m GoodCompile:  { ¥ size -- }
  353.     here  modstart 8 +  displ!        ¥ Store export table offs in header
  354.     all: $exp  n,                    ¥ Add export table to end
  355.     fixLinks: self                    ¥ fix dic links in module
  356.     here modstart -  -> size        ¥ Size of module
  357.     size  modstart 12 +  !            ¥ Store size in header
  358.     binName: self  name: fFcb        ¥ Set name of binary file
  359.     create: fFcb  ?error 139
  360.     'type BIN  'type Mops  set: fFcb    ¥ Type and signature
  361.     modstart  size  write: fFcb            ¥ Write out binary module
  362.     close: fFcb  drop
  363.     IF    msg# 140                    ¥ I/O error on writing bin file
  364.     ELSE
  365.         curs  -curs
  366.         cr  getName: fFcb type  ."  saved" cr
  367.         -> curs
  368.     THEN
  369. ;m
  370.  
  371. public
  372.  
  373. :m COMPILE:  { ¥ newModbase -- }
  374.     compMod  ?error 177                    ¥ Error if already compiling a module
  375.     release: self                        ¥ Get rid of old version, if loaded
  376.     context 32  put: $cxt                ¥ save CONTEXT since we're going
  377.                                         ¥ to do a temporary FORGET
  378.     DP -> svDP  latest -> svLatest  ^base -> compMod
  379.     get: loadpoint  (forget)  svDP -> DP
  380.     true -> cleanMod?
  381.     pushNew: loadFile
  382.     txtName: self  name: topFile
  383.     here -> modstart
  384.     modstart 32766 +  -> newModbase
  385.     16  reserve            ¥ Reserve space for header and offset to exports table.
  386.     ^base -> this_mod
  387.     newModbase LdFromMod
  388.     dateTime  modstart !                ¥ Put source date in bin module header
  389.     getDirID: topFile  modstart 4+ !    ¥ Also DirID of source file
  390.     drop: loadfile
  391.     0 -> this_mod
  392.     !exports: self
  393.     cleanMod?
  394.     IF    goodCompile: self            ¥ Everything's OK.  Do final housekeeping
  395.     THEN
  396.     unmod                            ¥ Also releases $cxt
  397.     release: $exp  ;m
  398.  
  399.  
  400. ¥ FIND: works like FIND, but just searches for a word in this module.
  401.  
  402. :m FIND: { s255 ¥ thrdOffs modCxt cxtOffs -- cfa T | -- s255 F }
  403.     load: self
  404.     s255                                    ¥ leave on stack for (find)
  405.     dup c@ 7 and 4*  -> thrdOffs            ¥ like what THREAD does
  406.     nptr: modHdl  size: modHdl +  32 -  -> modCxt
  407.     modCxt 4- @  -> cxtOffs
  408.     modCxt thrdOffs +  displace
  409.     dup NIF            ¥ thread is empty
  410.         drop false  EXIT
  411.     THEN
  412.     cxtOffs -
  413.     ( s255 1st-link )  (find)
  414. ;m
  415.  
  416. :m CLASSINIT:
  417.     -1  put: relOffs
  418.     dateTime put: dicDateTime  ;m
  419.  
  420. ;class
  421.  
  422.  
  423. : SETRELEASE    ¥ ( addr -- )
  424.     setRelease: [ this_mod ]  ;
  425.  
  426. : MLD
  427.     dup  load: **  ;
  428.  
  429. ' mld -> modLoad
  430.  
  431. : MOD?        ¥ ( cfa -- cfa b )
  432.     aligned_addr?  NIF  false  EXIT  THEN
  433.     dup >obj >classXt  ['] module  =  ;
  434.  
  435.  
  436. : ?DISP  { theCfa size -- }        ¥ handler to release selected modules
  437.     theCfa mod?  NIF  drop  EXIT  THEN
  438.     free size <            ¥ Do we still need space?
  439.     IF    >obj  ?release: module
  440.     ELSE    drop
  441.     THEN  ;
  442.  
  443.  
  444. ¥ PURGE forcibly releases all modules, no matter what.  It is a vector,
  445. ¥ defined in file Files.
  446.  
  447. : (PRG)  { theCfa size -- }    ¥ unlock and release
  448.     theCfa mod? NIF  drop  EXIT  THEN
  449.     >obj release: module  ;
  450.  
  451. : (PURGE)    ['] (prg)  big#  trav  ;
  452.  
  453. ' (purge) -> purge
  454.  
  455.  
  456. : NEEDSPACE    ¥ ( #bytes -- ) release modules until #bytes are available
  457.     false -> released?
  458.     freeblk drop  ['] ?disp swap trav  ;
  459.  
  460. : GS    big# needSpace  released?  ;
  461.  
  462. ' gs -> getSpace
  463.  
  464.  
  465. : FROM        ¥ ( -- ^mod sec# )
  466.     module                            ¥ Create module object
  467.     latest name> >obj  dup -> last_mod  28  ;
  468.  
  469.  
  470. : IMPORT{    ¥ ( ^mod sec# -- )
  471.     28 ?pairs  getImports: **  ;
  472.  
  473. : EXPORTS_CLASS
  474.     last_mod  exports_class: **  ;
  475.  
  476.  
  477.  
  478. (* EVAL" ... " performs an EVALUATE on the quoted string, with one important
  479.    difference to EVALUATE - it temporarily returns the dictionary to the
  480.    state it was in when the EVAL" was compiled.  This ensures that any
  481.    later redefinitions of words in the quoted string won't be used.  This
  482.    is usually what you want.  If you want redefinitions to be used, use
  483.    EVALUATE.
  484.    Note - we've put this definition here in the Modules file, since the
  485.    saving and restoring of the dictionary state is almost identical
  486.    to what has to be done during module compilation.
  487. *)
  488.  
  489. : (EVAL")
  490.     context 32  put: $evCxt        ¥ save CONTEXT since we're going
  491.                                 ¥ to do a temporary FORGET
  492.     DP -> evSvDP  latest -> evSvLatest
  493.     fence  0 -> fence            ¥ disable fence check on (forget) since
  494.                                 ¥  we might be in a module located below
  495.                                 ¥  the dic in memory!
  496.     r>                            ¥ caller addr is where we forget to
  497.     dup  (forget)
  498.     swap  -> fence                ¥ restore fence
  499.     evSvDP -> DP                ¥ restore DP (but context is still forgotten)
  500.     count
  501.     2dup + aligned  >r
  502.     unEval                        ¥ restore context etc.
  503.     evaluate  ;
  504.  
  505. : EVAL"
  506.     postpone (eval")
  507.     ,"                ¥ parse string delimited by " , add to dic
  508. ;                        immediate
  509.  
  510.  
  511. (* ***
  512. ¥ Testing:
  513.  
  514. : QQ    ." The right QQ!" cr  ;
  515.  
  516. from TESTMOD  import{ AA BB CC export_class }
  517.  
  518. : QQ    ." This is the wrong QQ!!!"  ;        ¥ This one shouldn't!
  519.  
  520. compile: testmod
  521. +echo
  522. : h mword hash 0 db mfa_offset ;
  523.  
  524. : LOOKFOR    Mword  find: testmod  ;
  525.  
  526. +echo
  527. true -> classinitTest
  528. export_class eee
  529.  
  530. endload
  531.  
  532. *** *)
  533.  
  534.  
  535. ¥ Now that's done, the next thing we need to do is set up our HFS file
  536. ¥ access:
  537.  
  538. from PATHSMOD    import{  OWP  GETPATHS  .PATHS  }
  539.  
  540. :f OPEN_WITH_PATHS    OWP  ;f
  541.  
  542. compile: pathsMod
  543.  
  544. true -> use_paths?
  545. " mops.paths"  getPaths
  546.  
  547. ¥ Right, we now have HFS paths, so we can access our source files in
  548. ¥ different folders.
  549.  
  550. from CALL1&LMOD    import{  CallFirst  CallLast  (GET)  (C1)  (CL)  }
  551.  
  552. ' (get) -> get1st&last
  553. ' (C1)  -> doCall1st
  554. ' (CL)  -> doCallLast
  555.  
  556. compile: call1&Lmod
  557.  
  558.  
  559. 0    value        CASE_TYPE
  560.  
  561. from CASEMOD     import{  case[ ]=> ], range]=> range], default=> ]case
  562.                             select[  ]select }
  563.  
  564. compile: caseMod
  565.  
  566. : SELECT{    postpone select[  ;        immediate
  567. : }SELECT    postpone ]select  ;        immediate
  568. : IS{        postpone ]=>      ;        immediate
  569. : }END        postpone [          ;        immediate
  570. : DEFAULT{    postpone ]  postpone default=>  postpone drop  ;    immediate
  571.  
  572.  
  573. from TOOL        import{  CALL ASMCALL FCALL GLOBAL $>GLOB  }
  574. compile: tool
  575.  
  576. from CALLSMOD  import{  SYSCALL KONST $>KONST  }
  577. compile: callsMod
  578.  
  579. from ASMMOD    import{  ASM :CODE :MCODE TOCODE  }
  580. compile: asmmod
  581.  
  582. endload
  583.  
  584.  
  585. ¥ More testing stuff:
  586.  
  587. +echo
  588.  
  589.  
  590. :class    HAHA    super{ int }
  591.  
  592. callLast    print:
  593.  
  594. :m BAtest:
  595.     1 2 3 . . .  ;m
  596. ;class
  597.  
  598. :class SUBHAHA  super{ haha }
  599.  
  600. callLast    dump:
  601.  
  602. :m BAtest:  -9 -8 -7 . . .  ;m
  603.  
  604. ;class
  605.  
  606. haha    hh
  607. subhaha    ss
  608.  
  609. : q db batest: hh  batest: ss  ;
  610.  
  611.  
  612. : QQ    ." QQ here.  Hello. "  ;        ¥ This gets called from testMod
  613.  
  614. variable VB
  615.  
  616. compile: testmod2
  617.